(in-package :lilu-apropos)

;;;
;;; interactive apropos
;;;

(defparameter *symbol-options*
  (list '(:symbol-name-regex :regex "")
        '(:package-name-regex :regex "")
        '(:external-p (member :any :yes :no) :yes)
        '(:documentation-p (member :any :yes :no) :any)
        '(:location-p (member :any :yes :no) :any)
        (list :bound-to (append (list 'member :any) *symbol-bounding-types*) :any)
        '(:subclass-of t)))

(defclass symbol-iapropos (iapropos)
  ((package-iapropos :initform (make-instance 'package-iapropos)
                     :reader symbol-iapropos-package-iapropos))
  (:default-initargs
   :options *symbol-options*
   :sorting-symbol-p t
   :remove-duplicate-p t
   :obj->symbol-fn #'identity
   :match-object-fn #'%symbol-iapropos-match-symbol-p)
  (:documentation "Interactive apropos class based on cl-ppcre and swank"))

(defun symbol-iapropos-set-option-values (iapropos &rest args
                                                 &key reset-p symbol-name-regex package-name-regex external-p
                                                   documentation-p location-p bound-to subclass-of
                                                   metaclass-of filter-fn)
  (declare (ignore symbol-name-regex package-name-regex external-p
                   documentation-p location-p bound-to subclass-of
                   metaclass-of filter-fn))
  (apply #'iapropos-set-option-values iapropos :reset-p reset-p args))

(defmethod iapropos-update-search ((iapropos symbol-iapropos) changes)
  (with-slots (package-iapropos
               max-result-length
               result-overflow-p)
      iapropos
    (anaphora:awhen (assoc :package-name-regex changes)
      (package-iapropos-set-option-values package-iapropos :package-name-regex (third anaphora:it)))
    (let ((out)
          (i 0)
          (cached-matching-packages (package-iapropos-matched-packages package-iapropos)))
      (setf result-overflow-p nil)
      (block iter
        (with-package-iterator (next cached-matching-packages :external :internal)
          (loop (multiple-value-bind (morep symbol) (next)
                  (when (not morep)
                    (return-from iter))
                  (when (= i max-result-length)
                    (setf out (remove-duplicates out))
                    (setf i (length out))
                    (when (= i max-result-length)
                      (setf result-overflow-p t)
                      (return-from iter)))
                  (when (%symbol-iapropos-match-symbol-p iapropos symbol)
                    (push symbol out)
                    (incf i))))))
      out)))

(defgeneric symbol-iapropos-matched-symbols (symbol-iapropos)
  (:documentation "Return the list of symbols that match the specified criteria")
  (:method  ((symbol-iapropos symbol-iapropos))
    (with-slots (cached-matched-objects) symbol-iapropos
      cached-matched-objects)))

(defgeneric symbol-iapropos-matched-packages (symbol-iapropos)
  (:documentation "Return the list of packages that match the specified criteria")
  (:method ((symbol-iapropos symbol-iapropos))
    (with-slots (package-iapropos) symbol-iapropos
      (package-iapropos-matched-packages package-iapropos))))

(defmethod iapropos-matched-object-packages ((iapropos symbol-iapropos))
  (with-slots (package-iapropos) iapropos
    (values (package-iapropos-matched-packages package-iapropos)
            nil)))

(defun %symbol-iapropos-match-symbol-p (iapropos symbol)
  (with-slots (option-values cached-regexp-scanners bound-to) iapropos
    (let ((bound-to (getf option-values :bound-to)))
      (and
       (when-option-regex (:symbol-name-regex cached-regexp-scanners)
         (cl-ppcre:scan scanner (symbol-name symbol)))
       (when-option-yes/no (:external-p option-values)
         (symbol-external-p symbol))
       (when-option (:bound-to option-values)
         (if (eql value :any)
             t
             (symbol-bound-to symbol value)))
       (if (and bound-to (not (eql bound-to :any)))
           (and
            (when-option-yes/no (:documentation-p option-values)
              (symbol-documentation symbol bound-to))
            (when-option-yes/no (:location-p option-values)
              (symbol-location symbol bound-to)))
           t)
       (if (eql bound-to :class)
           (and
            (when-option (:subclass-of option-values)
              (subtypep symbol value)))
            t)))))

(defmethod iapropos-describe-object ((iapropos symbol-iapropos) symbol)
   (with-slots (option-values) iapropos
     (let ((bound-to (getf option-values :bound-to)))
       (when (equal (length (list-symbol-bounding-types symbol)) 1)
         (setf bound-to (car (list-symbol-bounding-types symbol))))
       (append
        (list :name (symbol-name symbol)
              :bound-to (list-symbol-bounding-types symbol))
        (unless (eql bound-to :any)
          (list
           :object (let ((obj (symbol-object symbol bound-to)))
                     (if (eql obj :missing)
                         :missing
                         (cons :object (symbol-object symbol bound-to))))
           :location (let ((loc (symbol-location symbol bound-to)))
                       (if loc (cons :file loc) :missing))
           :documentation (or (symbol-documentation symbol bound-to) :missing)
           :description (symbol-description symbol bound-to)))))))
